ADA Programming Guide/ADA Programming Guide.iso/ada_gnu/adainc/a-stwima.adb

Text File | 1996-01-30 | 16KB | 583 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                A D A . S T R I N G S . W I D E _ M A P S                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.6 $                              --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

package body Ada.Strings.Wide_Maps is

   ---------
   -- "=" --
   ---------

   --  The sorted, discontiguous form is canonical, so equality can be used

   function "=" (Left, Right : in Wide_Character_Set) return Boolean is
   begin
      return Left.all = Right.all;
   end "=";

   ---------
   -- "-" --
   ---------

   function "-"
     (Left, Right : in Wide_Character_Set)
      return        Wide_Character_Set
   is
      Result : Wide_Character_Ranges (1 .. Left'Length + Right'Length);
      --  Each range on the right can generate at least one more range in
      --  the result, by splitting one of the left operand ranges.

      N : Natural := 0;
      R : Natural := 1;
      W : Wide_Character;

   begin
      --  Basic loop is through ranges of left set

      for L in Left'Range loop

         --  W is lowest element of current left range not dealt with yet

         W := Left (L).Low;

         --  Skip by ranges of right set that have no impact on us

         while R <= Right'Length and then Right (R).High < W loop
            R := R + 1;
         end loop;

         --  Deal with ranges on right that create holes in the left range

         while R <= Right'Length and then Right (R).High < Left (L).High loop
            N := N + 1;
            Result (N).Low  := W;
            Result (N).High := Right (R).High;
            R := R + 1;
         end loop;

         --  Now we have to output the final piece of the left range if any

         if R <= Right'Length and then Right (R).Low <= Left (L).High then

            --  Current right range consumes all of the rest of left range

            if Right (R).Low < W then
               null;

            --  Current right range consumes part of the rest of left range

            else
               N := N + 1;
               Result (N).Low  := W;
               Result (N).High := Wide_Character'Pred (Right (R).Low);
            end if;

         --  Rest of left range to be retained complete

         else
            N := N + 1;
            Result (N).Low  := W;
            Result (N).High := Left (L).High;
         end if;
      end loop;

      return new Wide_Character_Ranges'(Result (1 .. N));
   end "-";

   -----------
   -- "and" --
   -----------

   function "and"
     (Left, Right : in Wide_Character_Set)
      return        Wide_Character_Set
   is
      Result : Wide_Character_Ranges (1 .. Right.all'Length + 1);
      N      : Natural := 0;
      L, R   : Natural := 1;

   begin
      --  Loop to search for overlapping character ranges

      loop
         exit when L > Left.all'Last;
         exit when R > Right.all'Last;

         if Left (L).High < Right (R).Low then
            L := L + 1;

         elsif Right (R).High < Left (L).Low then
            R := R + 1;

         --  Here we have Left.High  >= Right.Low
         --           and Right.High >= Left.Low
         --  so we have an overlapping range

         else
            N := N + 1;
            Result (N).Low :=
              Wide_Character'Max (Left (L).Low,  Right (R).Low);
            Result (N).High :=
              Wide_Character'Min (Left (L).High, Right (R).High);
            L := L + 1;
            R := R + 1;
         end if;
      end loop;

      return new Wide_Character_Ranges'(Result (1 .. N));
   end "and";

   -----------
   -- "not" --
   -----------

   function "not"
     (Right  : in Wide_Character_Set)
      return Wide_Character_Set
   is
      Result : Wide_Character_Ranges (1 .. Right.all'Length + 1);
      N      : Natural := 0;

   begin
      if Right (1).Low /= Wide_Character'First then
         N := N + 1;
         Result (N).Low  := Wide_Character'First;
         Result (N).High := Wide_Character'Pred (Right (1).Low);
      end if;

      for K in 1 .. Right.all'Last - 1 loop
         N := N + 1;
         Result (N).Low  := Wide_Character'Succ (Right (K).High);
         Result (N).High := Wide_Character'Pred (Right (K + 1).Low);
      end loop;

      if Right (Right.all'Last).High /= Wide_Character'Last then
         N := N + 1;
         Result (N).Low  := Wide_Character'Succ (Right (Right'Last).High);
         Result (N).High := Wide_Character'Pred (Right (1).Low);
      end if;

      return new Wide_Character_Ranges'(Result (1 .. N));
   end "not";

   ----------
   -- "or" --
   ----------

   function "or"
     (Left, Right : in Wide_Character_Set)
      return        Wide_Character_Set
   is
      Result : Wide_Character_Ranges (1 .. Left'Length + Right'Length);
      N      : Natural;
      L, R   : Natural;

   begin
      if Left'Length = 0 then
         return Right;

      elsif Right'Length = 0 then
         return Left;

      else
         N := 1;
         Result (1) := Left (1);
         L := 2;
         R := 1;

         loop
            --  Collapse next left range into current result range if possible

            if L <= Left'Length
              and then Wide_Character'Pos (Left (L).Low) <=
                       Wide_Character'Pos (Result (N).High) + 1
            then
               Result (N).High :=
                 Wide_Character'Max (Result (N).High, Left (L).High);
               L := L + 1;

            --  Collapse next right range into current result range if possible

            elsif R <= Right'Length
              and then Wide_Character'Pos (Right (R).Low) <=
                       Wide_Character'Pos (Result (N).High) + 1
            then
               Result (N).High :=
                 Wide_Character'Max (Result (N).High, Right (R).High);
               R := R + 1;

            --  Otherwise establish new result range

            else
               if L <= Left'Length then
                  N := N + 1;
                  Result (N) := Left (L);
                  L := L + 1;

               elsif R <= Right'Length then
                  N := N + 1;
                  Result (N) := Right (R);
                  R := R + 1;

               else
                  exit;
               end if;
            end if;
         end loop;
      end if;

      return new Wide_Character_Ranges'(Result (1 .. N));
   end "or";

   -----------
   -- "xor" --
   -----------

   function "xor"
     (Left, Right : in Wide_Character_Set)
      return        Wide_Character_Set
   is
      Result : Wide_Character_Ranges (1 .. Left'Length + Right'Length);
      N      : Natural := 0;
      L, R   : Natural := 1;

   begin
      return (Left or Right) - (Left and Right);
   end "xor";

   -----------
   -- Is_In --
   -----------

   function Is_In
     (Element : in Wide_Character;
      Set     : in Wide_Character_Set)
      return    Boolean
   is
      L, R, M : Natural;

   begin
      L := Set'First;
      R := Set'Last;

      --  Binary search loop. The invariant is that if Element is in any of
      --  of the constituent ranges it is in one between Set (L) and Set (R).

      loop
         if L > R then
            return False;

         else
            M := (L + R) / 2;

            if Element > Set (M).High then
               L := M + 1;
            elsif Element < Set (M).Low then
               R := M - 1;
            else
               return True;
            end if;
         end if;
      end loop;
   end Is_In;

   ---------------
   -- Is_Subset --
   ---------------

   function Is_Subset
     (Elements : in Wide_Character_Set;
      Set      : in Wide_Character_Set)
      return     Boolean
   is
      S : Positive := 1;
      E : Positive := 1;

   begin
      loop
         --  If no more element ranges, done, and result is true

         if E > Elements'Length then
            return True;

         --  If more element ranges, but no more set ranges, result is false

         elsif S > Set'Length then
            return False;

         --  Remove irrelevant set range

         elsif Set (S).High < Elements (E).Low then
            S := S + 1;

         --  Get rid of element range that is properly covered by set

         elsif Set (S).Low <= Elements (E).Low
            and then Elements (E).High <= Set (S).High
         then
            E := E + 1;

         --  Otherwise we have a non-covered element range, result is false

         else
            return False;
         end if;
      end loop;
   end Is_Subset;

   ---------------
   -- To_Domain --
   ---------------

   function To_Domain
     (Map  : in Wide_Character_Mapping)
      return Wide_Character_Sequence
   is
   begin
      return Map.Domain.all;
   end To_Domain;

   ----------------
   -- To_Mapping --
   ----------------

   function To_Mapping
     (From, To : in Wide_Character_Sequence)
      return     Wide_Character_Mapping
   is
      Domain : Wide_Character_Sequence (1 .. From'Length);
      Rangev : Wide_Character_Sequence (1 .. To'Length);
      N      : Natural := 0;
      K      : Natural := 0;

   begin
      if From'Length /= To'Length then
         raise Translation_Error;

      else
         for J in From'Range loop
            for M in 1 .. N loop
               if From (J) = Domain (M) then
                  raise Translation_Error;
               elsif From (J) < Domain (M) then
                  Domain (M + 1 .. N + 1) := Domain (M .. N);
                  Domain (M) := From (J);
                  Rangev (M) := To   (J);
                  goto Continue;
               end if;
            end loop;

            Domain (N + 1) := From (J);
            Rangev (N + 1) := To   (J);

            <<Continue>>
               N := N + 1;
         end loop;

         return (Domain => new Wide_Character_Sequence'(Domain (1 .. N)),
                 Rangev => new Wide_Character_Sequence'(Rangev (1 .. N)));
      end if;
   end To_Mapping;

   --------------
   -- To_Range --
   --------------

   function To_Range
     (Map  : in Wide_Character_Mapping)
      return Wide_Character_Sequence
   is
   begin
      return Map.Rangev.all;
   end To_Range;

   ---------------
   -- To_Ranges --
   ---------------

   function To_Ranges
     (Set :  in Wide_Character_Set)
      return Wide_Character_Ranges
   is
   begin
      return Set.all;
   end To_Ranges;

   -----------------
   -- To_Sequence --
   -----------------

   function To_Sequence
     (Set  : in Wide_Character_Set)
      return Wide_Character_Sequence
   is
      Result : Wide_String (Positive range 1 .. 2 ** 16);
      N      : Natural := 0;

   begin
      for J in Set'Range loop
         for K in Set (J).Low .. Set (J).High loop
            N := N + 1;
            Result (N) := K;
         end loop;
      end loop;

      return Result (1 .. N);
   end To_Sequence;

   ------------
   -- To_Set --
   ------------

   --  Case of multiple range input

   function To_Set
     (Ranges : in Wide_Character_Ranges)
      return   Wide_Character_Set
   is
      Result : Wide_Character_Ranges (Ranges'Range);
      N      : Natural := 0;
      J      : Natural;

   begin
      --  The output of To_Set is required to be sorted by increasing Low
      --  values, and discontiguous, so first we sort them as we enter them,
      --  using a simple insertion sort.

      for J in Ranges'Range loop
         for K in 1 .. N loop
            if Ranges (J).Low < Result (K).Low then
               Result (K + 1 .. N + 1) := Result (K .. N);
               Result (K) := Ranges (J);
               goto Continue;
            end if;
         end loop;

         Result (N + 1) := Ranges (J);

         <<Continue>>
            N := N + 1;
      end loop;

      --  Now collapse any contiguous or overlapping ranges

      J := 1;
      while J < N loop
         if Wide_Character'Pos (Result (J).High) + 1 >=
            Wide_Character'Pos (Result (J + 1).Low)
         then
            Result (J).High :=
              Wide_Character'Max (Result (J).High, Result (J + 1).High);

            N := N - 1;
            Result (J + 1 .. N) := Result (J + 2 .. N + 1);

         else
            J := J + 1;
         end if;
      end loop;

      return new Wide_Character_Ranges'(Result (1 .. N));

   end To_Set;

   --  Case of single range input

   function To_Set
     (Span : in Wide_Character_Range)
      return Wide_Character_Set
   is
   begin
      return new Wide_Character_Ranges'(1 => Span);
   end To_Set;

   --  Case of wide string input

   function To_Set
     (Sequence  : in Wide_Character_Sequence)
      return      Wide_Character_Set
   is
      R : Wide_Character_Ranges (1 .. Sequence'Length);

   begin
      for J in R'Range loop
         R (J) := (Sequence (J), Sequence (J));
      end loop;

      return To_Set (R);
   end To_Set;

   --  Case of single wide character input

   function To_Set
     (Singleton : in Wide_Character)
      return      Wide_Character_Set
   is
   begin
      return new Wide_Character_Ranges'(1 => (Singleton, Singleton));
   end To_Set;

   -----------
   -- Value --
   -----------

   function Value
     (Map     : in Wide_Character_Mapping;
      Element : in Wide_Character)
      return    Wide_Character
   is
      L, R, M : Natural;

   begin
      L := 1;
      R := Map.Domain'Last;

      --  Binary search loop

      loop
         --  If not found, identity

         if L > R then
            return Element;

         --  Otherwise do binary divide

         else
            M := (L + R) / 2;

            if Element < Map.Domain (M) then
               R := M - 1;

            elsif Element > Map.Domain (M) then
               L := M + 1;

            else --  Element = Map.Domain (M) then
               return Map.Rangev (M);
            end if;
         end if;
      end loop;
   end Value;

end Ada.Strings.Wide_Maps;